home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Applications / NIH Image 1.62b11 / src / User.p < prev    next >
Text File  |  1997-05-14  |  11KB  |  427 lines
  1. unit User;
  2.  
  3. {
  4. This module is the best place to put user additions to NIH Image. Uncomment
  5. the call to InitUser in Image.p to activate the User menu. Edit the "User"
  6. menu resource with ResEdit to customize the User menu.
  7. }
  8.  
  9.  
  10. interface
  11.  
  12.     uses
  13.         Types, Memory, QuickDraw, QuickDrawText, Packages, Menus, Events, Fonts, 
  14.         Scrap, ToolUtils, Resources, Errors, Palettes, StandardFile, Windows,
  15.         Controls, TextEdit, Files, Dialogs, TextUtils, Finder, MixedMode, Processes,
  16.         globals, Utilities, Graphics, Filters, Analysis;
  17.  
  18.  
  19.     procedure InitUser;
  20.     procedure DoUserCommand1;
  21.     procedure DoUserCommand2;
  22.     procedure DoUserMenuEvent (MenuItem: integer);
  23.     procedure OldUserMacroCode (CodeNumber: integer; Param1, Param2, Param3: extended);
  24.     procedure UserMacroCode (str: str255; Param1, Param2, Param3: extended);
  25.  
  26.  
  27. implementation
  28.  
  29. {User global variables go here.}
  30.     var
  31.         color, MinSpacing: integer;
  32.         SaveInfo: InfoPtr;
  33.         PeakRadius, Peakedness: extended;
  34.  
  35.  
  36.     procedure InitUser;
  37.     begin
  38.         UserMenuH := GetMenu(UserMenu);
  39.         InsertMenu(UserMenuH, 0);
  40.         DrawMenuBar;
  41. {Additional user initialization code goes here.}
  42.     end;
  43.  
  44.  
  45.     procedure DrawDot (row, column, RowOffset, ColumnOffset: integer; big: boolean);
  46.         var
  47.             h, v: integer;
  48.     begin
  49.         if big then begin
  50.                 for h := -1 to 1 do
  51.                     for v := -1 to 1 do
  52.                         PutPixel(column * 16 + ColumnOffset * 4 + h + 16, row * 16 + RowOffset * 4 + v + 16, color)
  53.             end
  54.         else
  55.             PutPixel(column * 16 + ColumnOffset * 4 + 16, row * 16 + RowOffset * 4 + 16, color);
  56.     end;
  57.  
  58.     procedure DrawNeighborhood (i, row, column: integer);
  59.  
  60.     begin
  61.         DrawDot(row, column, 0, 0, BitAnd(i, 1) = 1);
  62.         DrawDot(row, column, 0, 1, BitAnd(i, 2) = 2);
  63.         DrawDot(row, column, 0, 2, BitAnd(i, 4) = 4);
  64.         DrawDot(row, column, 1, 2, BitAnd(i, 8) = 8);
  65.         DrawDot(row, column, 2, 2, BitAnd(i, 16) = 16);
  66.         DrawDot(row, column, 2, 1, BitAnd(i, 32) = 32);
  67.         DrawDot(row, column, 2, 0, BitAnd(i, 64) = 64);
  68.         DrawDot(row, column, 1, 0, BitAnd(i, 128) = 128);
  69.         DrawDot(row, column, 1, 1, true);
  70.     end;
  71.  
  72.  
  73.     procedure SetColor (i: integer);
  74. {Color neighborhoods to show which ones would be removed on the first pass(150), second pass(100),}
  75. {or either pass(200) when using the Zhang and Suen thinning algorithm(CACM, Mar. 1984,236-239).}
  76.         var
  77.             p2, p3, p4, p5, p6, p7, p8, p9, A, B: integer;
  78.     begin
  79.         p2 := bsr(band(i, 2), 1);
  80.         p3 := bsr(band(i, 4), 2);
  81.         p4 := bsr(band(i, 8), 3);
  82.         p5 := bsr(band(i, 16), 4);
  83.         p6 := bsr(band(i, 32), 5);
  84.         p7 := bsr(band(i, 64), 6);
  85.         p8 := bsr(band(i, 128), 7);
  86.         p9 := band(i, 1);
  87.         A := 0;
  88.         if (p2 = 0) and (p3 = 1) then
  89.             A := A + 1;
  90.         if (p3 = 0) and (p4 = 1) then
  91.             A := A + 1;
  92.         if (p4 = 0) and (p5 = 1) then
  93.             A := A + 1;
  94.         if (p5 = 0) and (p6 = 1) then
  95.             A := A + 1;
  96.         if (p6 = 0) and (p7 = 1) then
  97.             A := A + 1;
  98.         if (p7 = 0) and (p8 = 1) then
  99.             A := A + 1;
  100.         if (p8 = 0) and (p9 = 1) then
  101.             A := A + 1;
  102.         if (p9 = 0) and (p2 = 1) then
  103.             A := A + 1;
  104.         B := p2 + p3 + p4 + p5 + p6 + p7 + p8 + p9;
  105.         color := 255;
  106.         if A = 1 then
  107.             if (B >= 2) and (B <= 6) then begin
  108.                     if ((p2 * p4 * p6 = 0) and (p4 * p6 * p8 = 0)) and ((p2 * p4 * p8 = 0) and (p2 * p6 * p8 = 0)) then
  109.                         color := 200
  110.                     else if (p2 * p4 * p6 = 0) and (p4 * p6 * p8 = 0) then
  111.                         color := 150
  112.                     else if (p2 * p4 * p8 = 0) and (p2 * p6 * p8 = 0) then
  113.                         color := 100;
  114.                 end;
  115.     end;
  116.  
  117.  
  118.     procedure DoUserCommand1;
  119. {Generates a table showing all possible 3x3 neighborhoods. This table is used}
  120. { for making up the "fate table" used by the Skeletonize command and the Wand tool.}
  121.         var
  122.             row, column, index: integer;
  123.     begin
  124.         row := 0;
  125.         column := 0;
  126.         if NewPicWindow('Fate Table', 600, 200) then
  127.             for index := 0 to 255 do begin
  128.                     SetColor(index);
  129.                     DrawNeighborhood(index, row, column);
  130.                     column := column + 1;
  131.                     if column = 32 then begin
  132.                             row := row + 1;
  133.                             column := 0;
  134.                         end;
  135.                 end;
  136.     end;
  137.  
  138.  
  139.     function isPeak (x, y, minValue: LongInt): boolean;
  140.         var
  141.             delta, angle, dx, dy: extended;
  142.             v, i, v2, maxv2, x2, y2, v2count, nSamples: integer;
  143.             sample: LineType;
  144.             minlower, count, nLower, maxCount: integer;
  145.             PeakFound: boolean;
  146.             mask: rect;
  147.     begin
  148.         isPeak := false;
  149.         v := MyGetPixel(x, y);
  150.         if v < minValue then
  151.             exit(isPeak);
  152.         if v <= MyGetPixel(x + 1, y) then
  153.             exit(isPeak);
  154.         if v <= MyGetPixel(x + 1, y + 1) then
  155.             exit(isPeak);
  156.         if v <= MyGetPixel(x, y + 1) then
  157.             exit(isPeak);
  158.         if v <= MyGetPixel(x - 1, y + 1) then
  159.             exit(isPeak);
  160.         if v < MyGetPixel(x - 1, y) then
  161.             exit(isPeak);
  162.         if (v < MyGetPixel(x - 1, y - 1)) then
  163.             exit(isPeak);
  164.         if v < MyGetPixel(x, y - 1) then
  165.             exit(isPeak);
  166.         if v < MyGetPixel(x + 1, y - 1) then
  167.             exit(isPeak);
  168.         nSamples := round(4 * PeakRadius);
  169.         delta := 2.0 * pi / nsamples;
  170.         angle := 0.0;
  171.         maxv2 := round((1.0 - Peakedness) * v);
  172.         for i := 1 to nSamples do begin
  173.                 dx := PeakRadius * cos(angle);
  174.                 dy := PeakRadius * sin(angle);
  175.                 sample[i] := round(GetInterpolatedPixel(x + dx, y + dy));
  176.                 angle := angle + delta;
  177.             end;
  178.         minLower := round(0.677 * nsamples);
  179.         PeakFound := false;
  180.         count := 0;
  181.         i := 1;
  182.         nLower := 0;
  183.         maxCount := nSamples + minLower;
  184.         repeat
  185.             if sample[i] <= maxv2 then
  186.                 nLower := nLower + 1
  187.             else
  188.                 nLower := 0;
  189.             PeakFound := nLower >= minLower;
  190.             i := i + 1;
  191.             if i > nSamples then
  192.                 i := 1;
  193.             count := count + 1;
  194.         until PeakFound or (count = maxCount);
  195.         if PeakFound then begin
  196.                 info := SaveInfo;
  197.                 with info^ do begin
  198.                         SetRect(RoiRect, x - MinSpacing + 1, y - MinSpacing + 1, x + MinSpacing, y + MinSpacing);
  199.                         with RoiRect do begin
  200.                                 if left < 0 then
  201.                                     left := 0;
  202.                                 if top < 0 then
  203.                                     top := 0;
  204.                                 if right > PicRect.right then
  205.                                     right := PicRect.right;
  206.                                 if bottom > PicRect.bottom then
  207.                                     bottom := PicRect.bottom;
  208.                             end;
  209.                         GetRectHistogram;
  210.                         PeakFound := histogram[0] = 0;
  211.                     end; {with}
  212.                 Info := UndoInfo;
  213.             end;
  214.         isPeak := PeakFound;
  215.     end;
  216.  
  217.  
  218.     procedure FindPeaks (minValue, PeakRadiusP, PeakednessP: extended);
  219.         var
  220.             x, y, i, iMinValue: integer;
  221.             AutoSelectAll: boolean;
  222.             srect, mask: rect;
  223.             count: LongInt;
  224.             t: FateTable;
  225.     begin
  226.         if NotRectangular or NotInBounds or NoUndo then
  227.             exit(FindPeaks);
  228.         iMinValue := round(minValue);
  229.         if iMinValue < 0 then
  230.             iMinValue := 0;
  231.         if iMinValue > 255 then
  232.             iMinValue := 255;
  233.         PeakRadius := PeakRadiusP;
  234.         if PeakRadius = 0.0 then
  235.             PeakRadius := 6.0;
  236.         if PeakRadius < 1.0 then
  237.             PeakRadius := 1.0;
  238.         if PeakRadius > 50.0 then
  239.             PeakRadius := 50.0;
  240.         MinSpacing := round(PeakRadius) - 1;
  241.         if MinSpacing < 1 then
  242.             MinSpacing := 1;
  243.         if MinSpacing > 4 then
  244.             MinSpacing := 4;
  245.         Peakedness := PeakednessP;
  246.         if Peakedness = 0.0 then
  247.             Peakedness := 0.2;
  248.         if Peakedness < 0.05 then
  249.             Peakedness := 0.05;
  250.         if Peakedness > 0.95 then
  251.             Peakedness := 0.95;
  252.         AutoSelectAll := not Info^.RoiShowing;
  253.         if AutoSelectAll then
  254.             SelectAll(true);
  255.         ShowWatch;
  256.         SetupUndo;
  257.         WhatToUndo := UndoEdit;
  258.         SetupUndoInfoRec;
  259.         SaveInfo := Info;
  260.         srect := info^.roiRect;
  261.         KillRoi;
  262.         ChangeValues(0, 0, 1);
  263.         info := UndoInfo;
  264.         count := 0;
  265.         with srect do
  266.             for y := top to bottom - 1 do begin
  267.                     if CommandPeriod then begin
  268.                             beep;
  269.                             Info := SaveInfo;
  270.                             leave;
  271.                         end;
  272.                     for x := left to right - 1 do
  273.                         if isPeak(x, y, iMinValue) then begin
  274.                                 count := count + 1;
  275.                                 Info := SaveInfo;
  276.                                 PutPixel(x, y, 0);
  277. {PutPixel(x - 1, y, 0);}
  278. {PutPixel(x - 1, y - 1, 0);}
  279. {PutPixel(x, y - 1, 0);}
  280.                                 SetRect(mask, x - 1, y - 1, x + 1, y + 1);
  281.                                 UpdateScreen(mask);
  282.                                 Info := UndoInfo;
  283.                                 if count < MaxMeasurements then begin
  284.                                         User1^[count] := x;
  285.                                         User2^[count] := y;
  286.                                     end;
  287.                                 if (y mod 50) = 0 then ShowMessage(concat(long2str(y), '  ', long2str(count)));
  288.                             end;
  289.                 end;
  290.         Info := SaveInfo;
  291.         if count < MaxMeasurements then begin
  292.                 UnsavedResults := false;
  293.                 ResetCounter;
  294.                 for i := 1 to count do begin
  295.                         ClearResults(i);
  296.                         xcenter^[i] := User1^[i];
  297.                         ycenter^[i] := User2^[i];
  298.                     end;
  299.                 mCount := count;
  300.                 UpdateList;
  301.                 ShowInfo;
  302.             end
  303.         else
  304.             PutError('"Max Measurements" is too small.');
  305.         ShowMessage(concat('Count=', long2str(count), crStr, 'Threshold=', long2str(iMinValue)));
  306.     end;
  307.  
  308.  
  309.  
  310.     procedure ComputeBirefringence (scale, offset: extended);
  311. {This an example of how to do image math using a UserCode macro routine.}
  312. {It executes the following formula}
  313.  
  314.       {SQRT ( ( I1 - I2 ) ^ 2 + ( I3 - I4 ) ^ 2 ) / ( I1 + I2 - I3 + I4 ) ,}
  315.  
  316. {where I1 , I2 , I3 , I4  are the first four slices of the current stack.}
  317. {The result in the fifth slice of the stack.}
  318.  
  319.         var
  320.             i1, i2, i3, i4, i5: LineType;
  321.             i, slice, row: integer;
  322.             mask: rect;
  323.             v, min, max: extended;
  324.             minstr, maxstr: str255;
  325.     begin
  326.         with info^ do begin
  327.                 if StackInfo = nil then
  328.                     exit(ComputeBirefringence);
  329.                 if StackInfo^.nSlices <> 5 then
  330.                     exit(ComputeBirefringence);
  331.                 min := 1.0e12;
  332.                 max := -1.0e12;
  333.                 for row := 0 to nLines - 1 do begin
  334.                         SelectSlice(1);
  335.                         GetLine(0, row, PixelsPerLine, i1);
  336.                         SelectSlice(2);
  337.                         GetLine(0, row, PixelsPerLine, i2);
  338.                         SelectSlice(3);
  339.                         GetLine(0, row, PixelsPerLine, i3);
  340.                         SelectSlice(4);
  341.                         GetLine(0, row, PixelsPerLine, i4);
  342.                         for i := 0 to PixelsPerLine - 1 do begin
  343.                                 v := sqrt(sqr(I1[i] - I2[i]) + sqr(I3[i] - I4[i])) / (I1[i] + I2[i] - I3[i] + I4[i]);
  344.                                 if v < min then
  345.                                     min := v;
  346.                                 if v > max then
  347.                                     max := v;
  348.                                 if v > 255 then
  349.                                     v := 255;
  350.                                 if v < 0 then
  351.                                     v := 0;
  352.                                 v := v * scale + offset;
  353.                                 i5[i] := round(v);
  354.                             end;
  355.                         SelectSlice(5);
  356.                         PutLine(0, row, PixelsPerLine, i5);
  357.                         SetRect(mask, 0, row, PixelsPerLine, row + 1);
  358.                         UpdateScreen(mask);
  359.                         if CommandPeriod then
  360.                             leave;
  361.                     end;
  362.             end;
  363.         RealToString(min, 1, 4, minstr);
  364.         RealToString(max, 1, 4, maxstr);
  365.         ShowMessage(concat('min=', minstr, crStr, 'max=', maxstr));
  366.     end;
  367.  
  368.  
  369.     procedure ShowNoCodeMessage;
  370.     begin
  371.         PutError('Requires user written Pascal routine. ');
  372.     end;
  373.  
  374.  
  375.     procedure DoUserCommand2;
  376.     begin
  377.         ShowNoCodeMessage
  378.     end;
  379.  
  380.  
  381.     procedure DoUserMenuEvent (MenuItem: integer);
  382.     begin
  383.         case MenuItem of
  384.             1: 
  385.                 DoUserCommand1;
  386.             2: 
  387.                 DoUserCommand2;
  388.         end;
  389.     end;
  390.  
  391.  
  392.     procedure OldUserMacroCode (CodeNumber: integer; Param1, Param2, Param3: extended);
  393.   {Obsolete version kept for backward compatibilty.}
  394.     begin
  395.         case CodeNumber of
  396.             1: 
  397.                 ShowNoCodeMessage;
  398.             2: 
  399.                 ShowNoCodeMessage;
  400.             3: 
  401.                 ShowNoCodeMessage;
  402.             4: 
  403.                 ShowNoCodeMessage;
  404.             5: 
  405.                 FindPeaks(param1, param2, param3);
  406.             otherwise
  407.                 ShowNoCodeMessage;
  408.         end;
  409.     end;
  410.  
  411.  
  412.     procedure UserMacroCode (str: str255; Param1, Param2, Param3: extended);
  413.     begin
  414.         MakeLowerCase(str);
  415.         if pos('peaks', str) <> 0 then begin
  416.                 FindPeaks(param1, param2, param3);
  417.                 exit(UserMacroCode);
  418.             end;
  419.         if pos('birefringence', str) <> 0 then begin
  420.                 ComputeBirefringence(param1, param2);
  421.                 exit(UserMacroCode);
  422.             end;
  423.         ShowNoCodeMessage;
  424.     end;
  425.  
  426.  
  427. end.